;;############################################################################
;; mosaic2.lsp
;; Copyright (c) 1998 by Forrest W. Young & Ernest Kwan
;; Code to implement mosaic plot object prototype.
;; Mosaic drawing algorithm by Ernest Kwan
;; File contains show-window and resize methods, 
;; code to draw and color tiles, 
;; to draw tickmarks, tick and rectangle labels, 
;; both statically and dynamically
;;############################################################################

;;;;;;;;;;;;;
;;SHOW WINDOW
;;;;;;;;;;;;;

(defmeth mosaic-proto :show-window ()
  (send self :resize)
  (call-next-method)
  (send self :redraw)
  )

(defmeth mosaic-proto :fix-margins ()
  (let ((lh (+ (send self :text-ascent) (send self :text-descent) 2))
        (nxlines 2) (nylines 2)
        (ways (send self :ways)))
    (when (= 1 ways) (setf nylines 0))
    (send self :setting-margins t)
    (send self :margin (- (* nylines lh) 36) 19 0 (- (* nxlines lh) 40))
    (send self :setting-margins nil)))


(defmeth graph-proto :another-margin (nways)
  (let ((lh (+ (send self :text-ascent) (send self :text-descent) 2))
        (nylines (if (= 1 nways) 0 2))
        )
    (apply #'send self :margin (list (- (* nylines lh) 36) 19 0 (- (* 2 lh) 40)))))

;;;;;;;;;;;;;;;;
;;RESIZE METHODS
;;;;;;;;;;;;;;;;

(defmeth mosaic-proto :resize ()
  (call-next-method)
  (send self :size-it))

(defmeth mosaic-proto :size-it ()
  (send self :start-buffering)
  (send self :rects nil)
  (send self :hilite-rect nil)
  (when (send self :ways)
        (send self :fix-it))
  (send self :buffer-to-screen)
  )


(defmeth mosaic-proto :fix-it ()
  (send self :original-mx 
        (coerce (+ (send self :content-rect) '(0 0 -6 -6)) 'vector))
    (send self :prepare)
    (send self :add-mosaic))

(defmeth mosaic-proto :redraw ()
  (call-next-method)
  (send self :draw-it))

(defmeth mosaic-proto :draw-it ()
  (let* ((ways (send self :ways))
         (cr (send self :content-rect))
         (center (+ (first cr) (floor (/ (third cr) 2))))
         (st1 (send self :legend1))
         (st2 (send self :legend2)))
    (when (and st1 st2)
    (send self :draw-text st1 center 30 1 0)
    (send self :draw-text st2 center 45 1 0))))

(defmeth mosaic-proto :redraw-background ()
  (let ((tw (+ (send self :text-ascent) (send self :text-descent) 2))
        (cr (send self :content-rect))
        (size (send self :size))
        (draw-color (send self :draw-color)))
    (when (send self :to-label)
          (send self :draw-axis-labels tw cr size))
    (when (and (send self :showing-labels) (not (send self :point-labels)))
          (send self :point-labels 
                (send self :make-rect-labels)))))

(defmeth mosaic-proto :redraw-content ()
  (send self :start-buffering)
  (call-next-method)
  (send self :paint-rects)
  (send self :add-grid)
  (send self :buffer-to-screen)
  )

(defmeth mosaic-proto :clear (&optional empty)
  (send self :start-buffering)
  (send self :rects nil)
  (send self :clear-points)
  (send self :clear-lines)
  (when empty (send self :to-label nil))
  (send self :redraw)
  (send self :buffer-to-screen)
  )
  
(defmeth mosaic-proto :switch-use-color ()
  (send self :use-color (not (send self :use-color)))
  (send self :redraw)
  (send self :use-color))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth mosaic-proto :row-col-midwids () 
;only works 2-way
;(break)
  (let* ((draw-mx (send self :draw-mx))
         (levels (send self :levels))
         (row-midwids (repeat nil (select levels 0)))
         (col-midwids (repeat nil (select levels 1)))
         (k 0)
         )
    (dotimes (i (select levels 1))
             (setf (select col-midwids i) 
                   (list (+ (select draw-mx k 0)
                            (floor (/ (select draw-mx k 2) 2)))
                         (select draw-mx k 2)))
             (dotimes (j (select levels 0))
                      (when (= i 0)
                            (setf (select row-midwids j) 
                                  (list (+ (select draw-mx k 1)
                                           (floor (/ (select draw-mx k 3) 2)))
                                        (select draw-mx k 3))))
                      (setf k (1+ k))))
    (list row-midwids col-midwids)))

(defmeth mosaic-proto :find-edges (coords rect-center-xy value index ncenters) 
  (let* ((position-min-coords (which (= value coords)))
         (center-xys (select rect-center-xy position-min-coords))
         (center-edges (mapcar #'(lambda (xy) (select xy index)) center-xys))
         (nvals (length coords))
         (result)
         )
    (dotimes (i nvals)
             (when (/= (length center-edges) ncenters)
                   (setf result
                         (combine 
                          (sort-and-permute 
                           coords (matrix (list nvals 1) (iseq nvals)) t)))
                   (setf center-xys 
                         (select (select rect-center-xy result) 
                                 (iseq  (+ i ncenters))))
                   (setf center-edges (sort-data
                         (mapcar #'(lambda (xy) (select xy index)) center-xys)))
                   (setf center-edges (remove-duplicates center-edges))
                   )
             (when (= ncenters (length center-edges))(return)))
    center-edges))
  

(defmeth mosaic-proto :make-rect-labels ()
  (let* ((labels (send self :level-labels))
         (nlevels (length labels))
         (reordered-labels (select labels (reverse (iseq nlevels))))
         (result (first reordered-labels))
         )
    (when (> nlevels 1)
          (mapcar #'(lambda (i)
            (setf result (string-product result (select reordered-labels (1+ i)) :reverse t)))
                  (iseq (1- nlevels))))
    result))

(defmeth mosaic-proto :make-dynamic-tick-mark-labels ()
  (let* ((labels (send self :level-labels))
         (nlevels (length labels))
         (reordered-labels (select labels (reverse (iseq nlevels))))
         (result (first reordered-labels))
         )
    (cond 
      ((> nlevels 1)
       (mapcar #'(lambda (i)
                   (setf result (string-list result (select reordered-labels (1+ i)) 
                                             :reverse t)))
               (iseq (1- nlevels))))
      (t (setf result (mapcar #'list result))))
;(printlist (List "dyanamic tick labels" result))
    result))




(defmeth mosaic-proto :paint-rects ()
  (let* ((rects (send self :rects))
         (shading (if rects
                        (if (and
                             (= (length (send self :correct-position-cells))   
                                (length (send self :shading)))
                             (not (send self :bar)))
                            (select (send self :shading) (send self :correct-position-cells))
                            (send self :shading))
                      (send self :shading)))
         ;(shading (send self :shading))
         (color-now (send self :draw-color))
         (color?  (and (send self :use-color) 
                       (> *color-mode* 0)))
         (fill? (send self :colored-tiles))
         (rangey (send self :range 1))
         (ytop  (second (apply #'send self :real-to-canvas 
                              (list 0 (second rangey)))))
         (ybot  (second (apply #'send self :real-to-canvas 
                              (list 0 (first rangey)))))
         (xywh) (doit t) (canvasxy) (canvaswh))
    (when rects
          (if (send self :bar) 
              (when (send self :color-key?)(send self :add-color-spectrum))
              (when (send self :shading) (send self :add-color-spectrum)))
          (dotimes (i (length rects))
                   (setf doit t)
                   (setf xywh (select rects i))
                   (setf canvasxy (+ (list 0 0)
                     (send self :scaled-to-canvas (first xywh) (second xywh))))
                   (setf canvaswh (+ (list 0 0)
                         (send self :scaled-to-canvas 
                               (+ (first xywh) (third xywh)) 
                               (- (second xywh) (fourth xywh)))))
                   (when (send self :shading)
                         (setf fill-color (fifth xywh))
                         (when (and fill? fill-color)
                               ;(apply #'pdf-make-color 'fillit fill-color)
                               (apply #'make-color 'fillit fill-color)
                               (send self :draw-color 'fillit)
                               (apply #'send self :paint-rect 
                                 (combine canvasxy (- canvaswh canvasxy)))))
                   (cond
                     ((> (select shading i)  .5) (send self :draw-color 'blue));red
                     ((< (select shading i) -.5) (send self :draw-color 'red))
                     (t (send self :draw-color 'black)))
                   (when (send self :bar)
                         (when (= (mod i (second (send self :levels))) 0)
                               (setf doit nil)))
                   (when doit ;(and (not (send self :bar)) doit)
                         (apply #'send self :frame-rect 
                                (combine canvasxy (- canvaswh canvasxy))))
                   )
          (send self :line-width 1)
          (send self :draw-color color-now))
    ))


(defmeth mosaic-proto :color-function (shade)
  (- 1 (abs (^ shade 2.5))))

(defmeth mosaic-proto :border-color-function (shade)
  (cond ((> shade .5) 'red) ((< shade  -.5) 'blue) (t 'black)))

(defmeth mosaic-proto :add-mosaic ()
  (send self :clear-lines)
  (let ((draw-mx (send self :draw-mx))
        (cr (send self :content-rect))
        (total (send self :total))
        (shading 
         (if (and
              (= (length (send self :correct-position-cells))   (length (send self :shading)))
              (not (send self :bar)))
             (select (send self :shading) (send self :correct-position-cells))
             (send self :shading)))
        ;(shading (send self :shading))
        (shade 0) 
        (value 0)
        (shade-list nil) 
        (color 'black) 
        (fill-color 'black)
        (type 0))
    (when (not shading) (setf color 'blue))
    (when draw-mx
          (dotimes (i total)
                   (when shading
                         (setf shade (select shading i))
                         (setf shade (/ shade 3.0))
                         (if (> shade 1) (setf shade 1))
                         (if (< shade -1) (setf shade -1))
                         (setf value (send self :color-function shade))
                         (if (< shade 0)
                             (setf shade-list (list 1 value value))
                             (setf shade-list (list value value 1))))
                   (send self :make-tiles
                         (aref draw-mx i 0)
                         (aref draw-mx i 1)
                         (aref draw-mx i 2)
                         (aref draw-mx i 3) 
                         :border-color color
                         :fill-color shade-list))) ;aquí hay algo por corregir
    ))


(defmeth mosaic-proto :make-tiles  
       (x y w h &key (draw t) (border-color 'black) (fill-color nil))
"Prepares information for drawing and coloring tiles."
  (let* ((corner1 (send self :canvas-to-scaled x y))
         (corner2 (send self :canvas-to-scaled (+ x w) y))
         (corner3 (send self :canvas-to-scaled (+ x w) (+ y h)))
         (corner4 (send self :canvas-to-scaled x (+ y h)))
         (width   (- (first  corner2) (first  corner1)))
         (height  (- (second corner1) (second corner4)))
         )
    (when (and draw corner1)
          (send self :rects 
                (add-element-to-list 
                 (send self :rects) 
                 (list (first corner1) (second corner1) 
                       width height fill-color border-color))))
    (combine corner1 (- corner3 corner1))))


(defmeth mosaic-proto :do-brush-motion (x y)
  (let* ((cr (send self :content-rect))
         (rects (send self :rects))
         (hilite-rect (send self :hilite-rect))
         (dc (send self :draw-color))
         (lw (send self :line-width))
         (bi (send self :brushing-info))
         (centers (send self :rect-centers))
         (colors (send self :color-values))
         (xywh) (canvasxy1) (canvasxy2) (strw)
         (draw-rect) (found) (doit t))
    (send self :propagating t)
    (cond 
      ((and (< (first cr) x (+ (first cr) (third cr)))
            (< (second cr) y (+ (second cr) (fourth cr))))
       (when (not (send self :shading)) (setf dc 'blue))
       (dotimes (i (length rects))
                   (setf xywh (select rects i))
                   (setf canvasxy1 
                         (send self :scaled-to-canvas (first xywh) (second xywh)))
                   (setf canvasxy2 
                         (send self :scaled-to-canvas 
                               (+ (first xywh) (third xywh)) 
                               (- (second xywh) (fourth xywh))))
                   (when (and (< (first  canvasxy1) x (first  canvasxy2))
                              (< (second canvasxy1) y (second canvasxy2)))
                         (when (or (not bi) (not (= i (first bi))))
                               (when (and bi (send self :propagating))
                                     (send self :dehilite-all-rects bi i))
                               (when (send self :bar)
                                     (when (= (mod i (second (send self :levels))) 0)
                                           (setf doit nil))
                                     )
                               (when doit
                                     (setf cx (first (select centers i)))
                                     (setf cy (second (select centers i)))
                                     (when (send self :bar)
                                           (when (send self :side-by-side)
                                                 (send self :draw-freq-line 
                                                       (second canvasxy1)))
                                           (when (and (send self :color-key?)
                                                      (<= (abs (select colors i)) 3))
                                                 (send self :draw-color-line 
                                                       (select colors i))))
                                     (send self :hilite-a-rect i 
                                           (combine canvasxy1 (- canvasxy2 canvasxy1)))
                                     (when (send self :propagating)
                                           (send self :hilite-other-rects i))
                                     (when (not (send self :propagating))
                                           (when bi
                                                 (apply #' send self :show-rect-label 
                                                        (combine bi nil))
                                                 (send self :show-tick-label 
                                                       (first bi) nil );(first bi)
                                                 ))
                                     (send self :show-rect-label i cx cy t) 
                                     (send self :show-tick-label i t );(first bi)
                                     (send self :brushing-info (list i cx cy)) 
                                     (setf found t)
                                     (return))))))
      (t
       (when (and (not found) (send self :brushing-info))
             (send self :dehilite-a-rect (first bi))
             (apply #'send self :show-rect-label 
                    (combine (send self :brushing-info) nil))
             (send self :show-tick-label
                   (first (send self :brushing-info)) nil)
             (send self :brushing-info nil)
             (send self :redraw))))))

(defmeth mosaic-proto :dehilite-all-rects (bi i)
  (send self :start-buffering)
  (send self :dehilite-a-rect (first bi))
  (send self :dehilite-a-rect (first bi))
  (send self :brushing-info nil)
  (send self :redraw)
  (send self :buffer-to-screen)
  )

(defmeth mosaic-proto :show-rect-label (i x y show)
  (let* ((dc (send self :draw-color))
         (bc (send self :back-color))
         (ch (send self :canvas-height))
         (cw (send self :canvas-width))
         (hth (ceiling (- (/ (+ (send self :text-ascent) 
                               (send self :text-descent)) 2) 1)))
         (correct-position-cells (when (not (send self :bar)) (send self :correct-position-cells)))
         (cellfreqs (if (not (send self :bar))
                           (select (send self :cells)  correct-position-cells)
                       (send self :cells)))
         (str) (strw) (diff)
         (colors (if (not (send self :bar))
                    (select (send self :color-values) correct-position-cells)
                    (send self :color-values)))
         ;(colors (send self :color-values))
        (point-labels (if (not (send self :bar))
                          (select (send self :point-labels) correct-position-cells)
                          (send self :point-labels)))
        )
    (send self :draw-mode 'xor)
    (when (send self :showing-labels)
          (setf str (select point-labels i))
          (setf strw (send self :text-width str))
          (setf diff (- (- x (ceiling (/ strw 2))) (first (send self :content-rect)) 4))
          (when (> diff 0) (setf diff 0)) 
          (send self :draw-text str (- x diff) (+ hth y) 1 0))
    (send self :draw-text 
          (format nil "f=~a" (select cellfreqs i)) 3 (- ch hth) 0 0)
    (send self :draw-text
          (format nil "c=~4,1f" (select colors i)) (- cw 3) (- ch hth) 2 0)
    ;(print (select colors i))
    (send self :draw-color-line (select colors i))
    (send self :draw-mode 'normal)
    (send self :back-color bc)
    (send self :draw-color dc)))

(defmeth mosaic-proto :draw-freq-line (y)
  (let* ((lw (send self :line-width))
         (min-x (first (send self :range 0)))
         (x (first (send self :real-to-canvas min-x 0)))
         )
    (send self :line-width 3)
    (send self :draw-line (- x 6) (- y 1) (- x 8) (- y 1))
    (send self :line-width lw)))

(defmeth mosaic-proto :draw-color-line (color-value)
  (let* ((lw (send self :line-width))
         (rangey (send self :range 1))
         (miny (first  rangey))
         (maxy (second rangey))
         (c (/ (+ color-value 3) 6))
         (real-y (+ miny (* c (- maxy miny))))
         (maxx (second (send self :range 0)))
         (canvas-xy (send self :real-to-canvas maxx real-y)))
    (send self :line-width 3)
    (apply #'send self :draw-line 
           (combine (+ (list 5 0) canvas-xy) (+ canvas-xy (list 6 0))))
    (apply #'send self :draw-line 
           (combine (+ (list 19 0) canvas-xy) (+ canvas-xy (list 20 0))))
    (send self :line-width lw)
    ))
  
(defmeth mosaic-proto :show-tick-label (i show &optional bi)
  (let* ((dynamic-tick-mark-labels (send self :dynamic-tick-mark-labels))
         (y-tick-mark-locs (send self :y-tick-mark-locs))
         (x-tick-mark-locs (send self :x-tick-mark-locs))
         (xy-show (send self :tick-marks-showing))
         (dc (send self :draw-color))
         (rowi)
         (coli)
         (result)
         (nlevels (mapcar #'length (send self :level-labels)))
         (nlabels (length (send self :way-labels)))
         (strw) (x) (y)
         (colib4 2)
         (rh (+  (send self :text-ascent) (send self :text-descent)))
         )
    (when (not show) (send self :draw-color 'white))
    (setf result (send self :find-tick-info i 0))
    (setf coli (third result))
    (setf str (first result))
    (setf x (select (select x-tick-mark-locs 0) coli))
    (setf y (select x-tick-mark-locs 1))
    (setf strw (send self :text-width str))
  ; (send self :draw-color 'red)
    (send self :frame-rect (- x 1 (ceiling (/ strw 2))) (- y rh (- 2)) (+ strw 4) rh)
  ; (send self :draw-color dc)
    (send self :draw-line x (- y rh (- 2)) x (- y rh))
    (when (not (first xy-show))
          (send self :draw-text str x y 1 0))
    (when ;(and (not (send self :bar)) (> nlabels 1))
          (> nlabels 1)
          (setf result (send self :find-tick-info i 1))
          (setf rowi (third result))
          (unless (and (send self :bar) (= rowi 0))
                  (when bi (setf old-result (send self :find-tick-info bi 1)))
                  (when (or (not bi) (/= rowi (third old-result)))
                        (setf str (first result))
                        (setf x (select y-tick-mark-locs 1))
                        (setf y (select (select y-tick-mark-locs 0) rowi))
                        (setf strw (send self :text-width str))
                        ;  (send self :draw-color 'red)
                        (send self :frame-rect (- x rh (- 1)) (- y 0 (ceiling (/ strw 2))) 
                              (+ rh 2) (+ strw 2))
                        ;  (send self :draw-color dc)
                        (send self :draw-line (+ x 2) y (+ x 4) y)
                        (when (not (second xy-show))
                              (send self :draw-text-up str x y 1 0)))))
    (when (not show) (send self :draw-color 'black))
    ))


(defmeth mosaic-proto :find-tick-info (recti c)
  (let* ((dynamic-tick-mark-labels 
          (if (not (send self :bar)) 
              (select (send self :dynamic-tick-mark-labels)
                      (send self :correct-position-cells))
              (send self :dynamic-tick-mark-labels)))
         (nlabels (length (send self :way-labels)))
         (nlevels (mapcar #'length (send self :level-labels)))
         (ticki 
          (position (select (select dynamic-tick-mark-labels recti) c)
                    (select (send self :level-labels) c) :test #'equal))
         (ticki2 ticki)
         (str (select (select dynamic-tick-mark-labels recti) c)))
    (when (> nlabels (+ c 2))
          (setf str (strcat str "*" 
                            (select (select dynamic-tick-mark-labels recti) (+ c 2))))
          (setf ticki2 
                (position (select (select dynamic-tick-mark-labels recti) (+ c 2))
                          (select (send self :level-labels) (+ c 2)) :test #'equal))
          (setf ticki2 (+ (* (select nlevels (+ c 2)) ticki) ticki2)))
    (list str ticki ticki2)))

(defmeth mosaic-proto :choose-connection ()
  (let* ((loc (send self :location))
         (choice (choose-item-dialog 
                    "Choose Connection Type" 
                    '("None" "Rows" "Columns" "Rows and Columns")
                  :initial (send self :connection-type)
                  :location (+ loc '(40 40))
                  )))
    (when choice (send self :connection-type choice))
    choice))

(defmeth mosaic-proto :hilite-other-rects (i )
  (let* ((labels (send self :dynamic-tick-mark-labels))
         (this-label (select labels i))
         (rects (send self :rects))
         (nlabels (length (send self :way-labels)))
         (other-rects)
         (contype (send self :connection-type))
         )
    (when (and (> contype 0) (> nlabels 1))
          (flet ((remove-them (c)
                   (remove i
                    (which (mapcar 
                            #'(lambda (lab)
                                (if (< nlabels (+ c 3)) 
                                    (equal (select lab c) 
                                           (select this-label c))
                                    (and (equal (select lab c) 
                                                (select this-label c))
                                         (equal (select lab (+ c 2))
                                                (select this-label (+ c 2))))))
                            labels)))))
            (case contype
              (1 (setf other-rects (remove-them 1)))
              (2 (setf other-rects (remove-them 0)))
              (3 (setf other-rects (combine (remove-them 0) (remove-them 1))))
              )
            (mapcar #'(lambda (rect) 
                      (send self :hilite-a-rect rect t :dehilite nil :width 2)) 
                  other-rects)
            ))))

(defmeth mosaic-proto :hilite-a-rect 
  (i  &optional draw-rect &key (dehilite t) (width 2))
  (let* ((rects (send self :rects))
         (hilite-rect (send self :hilite-rect))
         (dc (send self :draw-color))
         (dchere 'black)
         (lw (send self :line-width))
         (color? (and (send self :use-color) (> *color-mode* 0)))
         (shading (if rects
                        (if (and
                             (= (length (send self :correct-position-cells))   
                                (length (send self :shading)))
                             (not (send self :bar)))
                            (select (send self :shading) (send self :correct-position-cells))
                            (send self :shading))
                      (send self :shading)))
         (xywh)
         (canvasxy1)
         (canvasxy2)
         (draw-rect)
         (fill-color (select (select rects i) 4))
         )
    (cond
      ((> (select shading i)  .5) (setf dchere 'blue));red
      ((< (select shading i) -.5) (setf dchere 'red))
      (t (setf dchere 'black)))
    (when (not color?) (setf dchere 'black))
    (when (not draw-rect)
          (setf xywh (select rects i))
          (setf canvasxy1 (send self :scaled-to-canvas (first xywh) (second xywh)))
          (setf canvasxy2 (send self :scaled-to-canvas 
                                (+ (first xywh) (third xywh)) 
                                (- (second xywh) (fourth xywh))))
          (setf draw-rect (combine canvasxy1 (- canvasxy2 canvasxy1))))
    (when (and dehilite hilite-rect
               (not (every #'= (first hilite-rect) draw-rect)))
          (send self :dehilite-a-rect i draw-rect))
    (send self :draw-color dchere)
    (send self :line-width width)
    (apply #'send self :frame-rect draw-rect)
    (send self :hilite-rect (list draw-rect (fifth xywh)))
    (send self :draw-color dc)
    (send self :line-width lw)))

(defmeth mosaic-proto :dehilite-a-rect (i &optional draw-rect)
  (let* ((rects (send self :rects))
         (hilite-rect (send self :hilite-rect))
         (dc (send self :draw-color))
         (dchere (send self :draw-color))
         (color? (and (send self :use-color) (> *color-mode* 0)))
         (lw (send self :line-width))
         )
    (when (and color? (not (send self :shading))) (setf dc 'blue))
    (when (not draw-rect)
          (setf xywh (select rects i))
          (setf canvasxy1 (send self :scaled-to-canvas (first xywh) (second xywh)))
          (setf canvasxy2 (send self :scaled-to-canvas 
                                    (+ (first xywh) (third xywh)) 
                                    (- (second xywh) (fourth xywh))))
          (setf draw-rect (combine canvasxy1 (- canvasxy2 canvasxy1))))
    (send self :line-width 2)
    (cond 
      ((second hilite-rect)
       (when color?
             (apply #'make-color 'fillit (second hilite-rect))
             (send self :draw-color 'fillit)))
      (t 
       (send self :draw-color 'white)))
    (apply #'send self :frame-rect (first hilite-rect))
    (send self :line-width 1)
  ; (unless (send self :bar)
            (send self :draw-color dc)
            (apply #'send self :frame-rect (first hilite-rect))
   ;        )
    (send self :draw-color dchere)
    ))
  